;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;;
;;; shader.lisp --- OpenGL, Shaders, and Lisp
;;;
;;; Copyright (C) 2011, John Miller  <JohnPantagruel@gmail.com>
;;;   All rights reserved.


(in-package :lib.gl) ;; Maybe move to lib.gl?

;; Just like in OpenGL SuperBible:
(defun load-shader-pair-with-attributes (vprog fprog &rest attribs)
  (let ((vshader (gl:create-shader :vertex-shader))
	(fshader (gl:create-shader :fragment-shader))
	handle)
    (gl:shader-source vshader vprog)
    (gl:compile-shader vshader)
    (unless (gl:get-shader vshader :compile-status)
      (error "Error compiling vertex shader: ~A" (gl:get-shader-info-log vshader)))
    (gl:shader-source fshader fprog)
    (gl:compile-shader fshader)
    (unless (gl:get-shader fshader :compile-status)
      (error "Error compiling fragment shader: ~A" (gl:get-shader-info-log fshader)))
    (setq handle (gl:create-program))
    (gl:attach-shader handle vshader)
    (gl:attach-shader handle fshader)
    (when attribs
      (iter (for (id name) in attribs)
            (gl:bind-attrib-location handle id name)))
    (gl:link-program handle)
    (gl:delete-shader vshader)
    (gl:delete-shader fshader)
    (unless (gl:get-program handle :link-status)
      (error "Error linking program: ~A" (gl:get-program-info-log handle)))
    handle))

;;; Lispy Shader Progamming

(defparameter *defined-vshaders* (make-hash-table))
(defparameter *defined-fshaders* (make-hash-table))

(defun get-vertex-shader (named)
  (gethash named *defined-vshaders*))

(defun get-fragment-shader (named)
  (gethash named *defined-fshaders*))

(defparameter *special-variable-names*
    '(("gl-position" . "gl_Position")
      ("gl-frag-color" . "gl_FragColor")
      ("gl-fragcolor" . "gl_FragColor")))

(defparameter *default-shader-header*
  "#version 330")

(defstruct shader-source
  name
  version
  attributes ;; these are shader-attribute structs
  code)

(defmethod make-load-form ((ss shader-source) &optional env)
  (make-load-form-saving-slots ss :environment env))

(defstruct shader-attribute
  type
  location
  storage
  name
  string)

(defmethod make-load-form ((sa shader-attribute) &optional env)
  (make-load-form-saving-slots sa :environment env))

(defun list-shader-sources ()
  (iter (for (k  v) in-hashtable *defined-vshaders*)
        (collecting k)))

(defun get-shader-source-pair (name)
  (list (gethash name *defined-vshaders*)
        (gethash name *defined-fshaders*)))

(defun to-camel-case (var)
  (let ((strname (string-downcase (format nil "~A" (symbol-name var)))))
    (or (cdr (assoc strname *special-variable-names* :test #'string-equal))
	(and (not (find #\- strname))
	     strname)
	(remove #\- (string-capitalize strname :start (position #\- strname))))))

(defun bind-shader-attributes (args)
  (flet ((parse-def (type spec)
           (let ((store (car spec))
                 (nm (cadr spec)))
             (make-shader-attribute :type type
                                    :storage store
                                    :name nm
                                    :string 
                                    (format nil "~A ~A ~A;" 
                                            (string-downcase (symbol-name type))
                                            (string-downcase (symbol-name store))
                                            (to-camel-case nm))))))
    (let ((attribs '()))
      (dolist (argset args (nreverse (alexandria:flatten attribs)))
        (push (nreverse (iter (for def in (cdr argset))
                             (collecting (parse-def (car argset) def))))
              attribs)))))

(defparameter *shader-operators* '(= * + - /))
(defparameter *shader-specials* '(let setq))

(defun parse-shader-operator (operator form)
   (with-output-to-string (expr)
     (format expr "~A" (parse-shader-form (first form)))
     (dolist (f (rest form))
       (if (listp f)
           (format expr " ~A (~A)" operator (parse-shader-form f))
           (format expr " ~A ~A" operator (parse-shader-form f))))))

(defun parse-shader-special (special form)
  (with-output-to-string (expr)
    (case special
      (let (destructuring-bind (args &body body) form 
             (dolist (a args)
               (format expr "~A ~A;" (to-camel-case (first a)) (parse-shader-form (rest a))))
             (format expr "~%~A" (parse-shader-form body))))
      (setq (format expr "~A = ~A;" (parse-shader-form (car form)) (parse-shader-form (cdr form)))))))

(defun parse-shader-form (form)
  (cond ((numberp form) (coerce form 'float))
        ((symbolp form) (to-camel-case form))
        ;((null form) nil)
        ((null (cdr form)) (parse-shader-form (car form)))
        ((listp (car form)) (format nil "~A~%~A~%" 
                                    (parse-shader-form (car form))
                                    (parse-shader-form (rest form))))
        ((member (car form) *shader-specials*) (parse-shader-special (car form) (rest form)))
        ((member (car form) *shader-operators*)
         (format nil "~A" (parse-shader-operator (car form) (rest form))))
        (t (let ((fn (parse-shader-form (car form)))
                 (args (iter (for arg in (cdr form))
                             (collecting (parse-shader-form arg)))))
             (format nil "~A(~A~{,~A~})" fn (car args) (cdr args))))))

(defun parse-shader-body (body)
  (flet ((parse-args (args)
	   (if (null args) "void"))
	 (parse-body-forms (forms)
	   (let ((body ""))
	     (iter (for f in forms)
		   (setf body (concatenate 'string body (format nil "~A;~%" (parse-body-form f)))))
	     body)))
    (iter (for (head . defs) in body)
	  (collecting (cond ((eql head 'defun)
			     (let ((rtype (car defs))
				   (name (cadr defs))
				   (args (caddr defs))
				   (body (cdddr defs)))
			       (format nil "~A ~A(~A) ~%{~%~A}" 
				       (string-downcase (symbol-name rtype))
				       (to-camel-case name)
				       (parse-args args)
				       (parse-shader-form body)))))))))

(defun generate-shader-code (version attributes body)
  (with-output-to-string (code)
    (format code "#version ~A~%" version)
    (dolist (a attributes)
      (format code "~A~%" (shader-attribute-string a)))
    (dolist (b (parse-shader-body body) code)
      (format code "~A~%" b))))

(defmacro defshader (type version name args &body body)
  (let ((attribs (bind-shader-attributes args)))
    (let ((shader (make-shader-source :name name
                                       :version version
                                       :attributes attribs
                                       :code (generate-shader-code version attribs body))))
      (ecase type
        (:vertex `(setf (gethash ',name *defined-vshaders*) ,shader))
        (:fragment `(setf (gethash ',name *defined-fshaders*) ,shader))))))

;;; Creating shader 'functions'

(defun mklist (x) 
  "If x is a list return it, otherwise return the list of x"
  (if (listp x) x (list x)))

(defun shader-lambda-list (shader)
  (mapcar #'shader-attribute-name 
          (mklist (remove-if #'(lambda (a)
                                 (not (member (shader-attribute-type a) '(:in :attribute :uniform)))) 
                             (shader-source-attributes shader)))))

(defun shader-forms (shader)
  )

;;;; ---- Testing ---- ;;;;

(defparameter *identity-vs* "
#version 330
in vec4 vVertex;
in vec4 vColor;

out vec4 vVaryingColor;

void main(void)
{
   vVaryingColor = vColor;
   gl_Position = vVertex;
}")

(defparameter *identity-fs* "
#version 330

out vec4 vFragColor;
in vec4 vVaryingColor;

void main(void)
{
  vFragColor = vVaryingColor;
}")

(defun test-bind-shader-attributes ()
  (bind-shader-attributes '((:in (vec4 v-vertex)
			     (vec4 v-color))
			    (:out (vec4 v-varying-color)))))


#|
(defshader :vertex "330" identity ((:in (vec4 v-vertex)
                                        (vec4 v-color))
                                   (:out (vec4 v-varying-color)))
  (defun :void main ()
           (setq v-varying-color v-color)
           (setq gl-position v-vertex)))


(defshader :fragment "330" identity ((:in (vec4 v-varying-color))
                                     (:out (vec4 v-frag-color)))
  (defun :void main ()
         (setq v-frag-color v-varying-color)))


(defshader :vertex "120" identity ((:attribute (vec4 v-vertex)
                                               (vec4 v-color))
                                   (:varying (vec4 v-varying-color)))
  (defun :void main ()
         (setq v-varying-color v-color)
         (setq gl-position v-vertex)))

(defshader :vertex "330" matrix-perspective ((:in (vec4 position)
                                                  (vec4 color))
                                             (:out (vec4 the-color))
                                             (:uniform (vec4 offset)
                                                       (mat4 perspective-matrix)))
  (defun :void main ()
         (let ((vec4 camera-pos))
           (setq camera-pos (+ position offset))
           (setq gl-position (* perspective-matrix camera-pos))
           (setq the-color color))))

(defshader :fragment "330" matrix-perspective ((:in (vec4 color))
                                               (:out (vec4 frag-color)))
  (defun :void main ()
         (setq frag-color color)))

(defshader :vertex "330" offset ((:in (vec4 position)
                                      (vec4 color))
                                 (:out (vec4 the-color))
                                 (:uniform (vec2 offset)))
  (defun :void main ()
         (setq gl-position (+ position (vec4 offset.x offset.y 0.0 0.0)))
         (setq the-color color)))
|#


